(defpackage problem
  (:use :cl)
  (:nicknames :p)
  (:shadow :log)
  (:export :problem
           :instructions
           :guidedp
           :answers
           :operations
           :mode
           :transformation
           :diagram
           :suppress-history
           :input-must-be-correct-p
           :correct-so-far-p
           :correct-input-p
           :empty-or-invalid-input-boxes-p
           :no-more-valid-operations-p
           :collapse-input-boxes
           :init
           :start
           :show-hint-fill-input
           :show-hint-already-wrong
           :show-hint-finished
           :show-hint-choose-operation
           :show-hint-make-selection
           :show-hint
           :clear-hints
           :num-hints
           :display-message
           :clear-message
           :toggle-selection
           :do-operation
           :finish-select-mode
           :collapse-input-boxes
           :fill-input-box
           :validate-input-box
           :finish-input-box
           :finish-input-arguments-collapse
           :finish-fill-mode
           :next-problem
           :finish-problem
           :wrong-tile-value
           :navigate-back-item
           :navigate-forward-item
           :navigate-first-mistake-item
           :navigate
           :navigate-clean-up
           :post-navigate-clean-up
           :calculate-reward
           :parse-old
           :log))

(in-package :problem)

(defclass problem (history:history)
  ((instructions :initarg :instructions)
   (guidedp :initform nil :initarg :guidedp :accessor guidedp)
   (operations :initarg :operations :accessor operations)
   (mode :type (member :select :fill) :initform :select :accessor mode)
   (answers :initform nil :accessor answers
            :documentation "Stores the possible answers for the operation that has been applied. only used in :fill mode.")
   (transformation :initform nil :accessor transformation
                   :documentation "Stores the current transformation when in :fill mode.")
   (diagram :initarg :diagram :accessor diagram)
   (incorrect-operations :initform 0 :accessor incorrect-operations)
   (fill-mistakes :initform 0 :accessor fill-mistakes)
   (num-hints :initform 0 :accessor num-hints)
   (reward-per-operation :initarg :reward-per-operation :accessor reward-per-operation)
   (penalty-per-fill-mistake :initarg :penalty-per-fill-mistake :accessor penalty-per-fill-mistake)
   (penalty-per-operation :initarg :penalty-per-operation :accessor penalty-per-operation)
   (penalty-per-hint :initarg :penalty-per-hint :accessor penalty-per-hint)
   (navigate-skip-fills-p :initform t :initarg :navigate-skip-fills-p :accessor navigate-skip-fills-p
                       :documentation "When non-NIL, fill mode diagrams are skipped when navigating the history")
   (suppress-history :initform nil :accessor suppress-history
                     :documentation "When non-NIL, history is not recorded.")
   (input-must-be-correct-p :initarg :input-must-be-correct-p :initform nil :accessor input-must-be-correct-p))
  (:default-initargs
   :reward-per-operation 7
    :penalty-per-fill-mistake 7
    :penalty-per-operation 3
    :penalty-per-hint 3))

(defgeneric init (problem diagram))
(defgeneric start (problem))
;;
(defgeneric show-hint-make-selection (problem transformation selected-nodes selection))
(defgeneric show-hint-choose-operation (problem op))
(defgeneric show-hint-finished (problem))
(defgeneric show-hint-already-wrong (problem))
(defgeneric show-hint-fill-input (problem tree))
(defgeneric show-hint (problem))
(defgeneric clear-hints (problem)
  (:method-combination progn :most-specific-last))
(defgeneric display-message (problem type fmt &rest args))
(defgeneric clear-message (problem type))
(defgeneric log (problem id &rest keys &key &allow-other-keys))
;; select mode
(defgeneric toggle-selection (problem node))
(defgeneric do-operation (problem opname))
(defgeneric finish-select-mode (problem last-diagram transformation)
  (:method-combination progn :most-specific-last))
;; fill mode
(defgeneric collapse-input-boxes (problem))
(defgeneric validate-input-box (problem node &optional value))
(defgeneric finish-input-box (problem node))
(defgeneric fill-input-box (problem node value))
(defgeneric finish-input-arguments-collapse (problem)
  (:method-combination progn :most-specific-last))
(defgeneric finish-fill-mode (problem)
  (:method-combination progn :most-specific-last))
;;
(defgeneric navigate (problem how &optional post-navigation-fn))
(defgeneric navigate-back-item (problem)
  (:documentation "Return the history item to jump to when navigating back"))
(defgeneric navigate-forward-item (problem)
  (:documentation "Return the history item to jump to when navigating forward"))
(defgeneric navigate-first-mistake-item (problem)
  (:documentation "Return the history item to jump to when navigating to first mistake"))
(defgeneric navigate-clean-up (problem how)
  (:documentation "Called when a navigate action was successful.")
  (:method-combination progn :most-specific-last))
(defgeneric post-navigate-clean-up (problem how)
  (:documentation "Called after a successful navigate action.")
  (:method-combination progn :most-specific-last))
(defgeneric next-problem (problem))
(defgeneric finish-problem (problem)
  (:method-combination progn :most-specific-last))
(defgeneric wrong-tile-value (problem node)
  (:method-combination progn :most-specific-last)
  (:documentation "This is called when the subject fills a tile with the wrong value and input-must-be-correct-p is non-NIL."))

(defmethod clear-hints progn ((problem problem))
  (d:clear-arrows (d:root (diagram problem))))

(defun update-guided-state (problem transition)
  (when (eq (guidedp problem) transition)
    (clear-message problem :hint)
    (setf (guidedp problem) nil)
    (clear-hints problem)))

(defmethod init ((problem problem) tree)
  (setf (d:root (diagram problem)) tree
        (h:current problem) (make-instance 'h:item
                                           :data (tree:copy-node tree t)
                                           :correctp t)))

(defmethod start ((problem problem))
  (when (guidedp problem) (show-hint problem)))

(defun input-argument-pairs (tree)
  (let ((inputs (d:collect-on-tree (lambda (n) (typep n 'd:input-argument))
                                   tree)))
    (sort (mapcar (lambda (n) (cons (d:id n) (d:quantity n)))
                  inputs)
          '< :key 'first)))

(defun correct-inputs-p (problem)
  (with-slots (diagram answers) problem
    (let ((pairs (input-argument-pairs (d:root diagram))))
      (and (find pairs answers :test 'equal) t))))

(defun correct-input-p (problem node)
  (and (find-if (lambda (a)
                  (find (cons (d:id node) (d:quantity node)) a :test 'equal))
                (answers problem))
       t))

(defun correct-inputs-so-far-p (problem)
  "Return T if the input arguments that are filled in all match one of
the answers. Ignore empty input arguments."
  (with-slots (diagram answers) problem
    (let ((pairs (input-argument-pairs (d:root diagram))))
      (find-if (lambda (answer)
                 (and (eql (length answer) (length pairs))
                      (loop for i in pairs
                         for j in answer
                         always (or (null (cdr i))
                                    (equal i j)))))
               answers))))

(defmethod collapse-input-boxes ((problem problem))
  (with-slots (h:current diagram mode transformation) problem
    (let ((correctp (correct-inputs-p problem)))
      (setf (d:root diagram) (o:collapse-input-arguments (d:root diagram)))
      ;; The old style evaluate needs the diagram to be cleaned up a
      ;; bit. This hook is where that code is called.
      (finish-input-arguments-collapse problem)
      (let ((copy (tree:copy-node (d:root diagram) t)))
        (d:clear-arrows copy)
        (unless (suppress-history problem)
          (h:push-item problem h:current))
        (setf mode :select
              h:current (make-instance 'h:item
                                       :data copy
                                       :correctp correctp)
              ;; clean up stale data for no real reason
              transformation nil))
      (unless correctp
        (incf (fill-mistakes problem)))
      (finish-fill-mode problem)
      (clear-message problem :all)
      (update-guided-state problem :stage)
      (when (guidedp problem) (show-hint problem)))))

(defmethod validate-input-box ((problem problem) (node d:input-argument) &optional (value (d:quantity node)))
  "Returns T if the input box was valid. Also displays a message if it isn't."
  (if (d:valid-input-p node value)
      (progn
        (clear-message problem :error)
        (log problem 'input-submit :node (d:id node) :value value :valid t)
        t)
      (progn
        (log problem 'input-submit :node (d:id node) :value value :valid nil)
        (display-message problem :error "Invalid input: ~a" value)
        nil)))

(defun empty-or-invalid-input-boxes-p (problem)
  (or (o:empty-green-boxes-p (d:root (diagram problem)))
      (d:find-if-on-tree (lambda (n)
                           (and (typep n 'd:input-argument)
                                (not (d:valid-input-p n (d:quantity n)))))
                         (d:root (diagram problem)))))

(defmethod finish-input-box ((problem problem) (node d:input-argument))
  "When the input is iteratively added, call this when the input box is done. Returns NIL if we're still in fill mode. T otherwise."
  (when (d:quantity node)
    (validate-input-box problem node)
    (if (or (empty-or-invalid-input-boxes-p problem)
            (and (or (guidedp problem)
                     (input-must-be-correct-p problem))
                 (not (correct-inputs-p problem))))
        (progn
          (when (and (not (empty-or-invalid-input-boxes-p problem))
                     (guidedp problem)
                     (correct-inputs-p problem))
            (log problem 'cannot-finish-fill :reason :incorrect-answers))
          (cond
            ((guidedp problem) (show-hint problem))
            ((input-must-be-correct-p problem)
             (p:display-message problem :error "~a is the wrong value." (d:quantity node))
             (wrong-tile-value problem node)))
          nil)
        (progn
          (collapse-input-boxes problem)
          t))))

(defmethod fill-input-box ((problem problem) (node d:input-argument) value)
  (when value
    (when (validate-input-box problem node value)
      (setf (d:quantity node) value))
    (if (or (o:empty-green-boxes-p (d:root (diagram problem)))
            (and (or (guidedp problem)
                     (input-must-be-correct-p problem))
                 (not (correct-inputs-p problem))))
        (cond
            ((guidedp problem) (show-hint problem))
            ((input-must-be-correct-p problem)
             (p:display-message problem :error "~a is the wrong value." value)
             (wrong-tile-value problem node)))
        (collapse-input-boxes problem))))

(defmethod finish-input-arguments-collapse progn ((problem problem)))
(defmethod finish-fill-mode progn ((problem problem)))
(defmethod finish-select-mode progn ((problem problem) last-diagram transformation))
(defmethod finish-problem progn ((problem problem)))
(defmethod wrong-tile-value progn ((problem problem) node))

(defmethod toggle-selection (problem node)
  (let ((thing (if (and (typep node 'd:argument)
                        (d:quantity node))
                   (tree:parent node)
                   node))
        (op (second (multiple-value-list (guide:get-selection (d:root (diagram problem)) (operations problem))))))
    (log problem (if (d:selected thing) 'unselect 'select) :node (d:id thing))
    (setf (d:selected thing) (not (d:selected thing)))
    ;; the stage ends when the user selected the boxes they were supposed to select
    (when (eq op
              (guide:operation-for-selection (d:root (p:diagram problem)) (operations problem)))
      (clear-message problem :error)
      (update-guided-state problem :stage))
    (when (guidedp problem) (show-hint problem))))

(defmethod do-operation ((problem problem) opname)
  "Returns T if the operation was successful, NIL if not."
  (with-slots (answers transformation h:current mode operations diagram) problem
    (when (eq mode :select)
      (let ((op (find opname operations :key 'o:name)))
        (when op
          (let ((copy (tree:copy-node (d:root diagram) t)))
            (multiple-value-bind (new-tree trans) (o:perform-operation (d:root diagram) op)
              (if new-tree
                  (progn
                    (setf (d:root diagram) new-tree
                          answers (o:generate-answers trans (d:root diagram))
                          transformation trans
                          mode :fill)
                    (setf (h:item-data h:current) copy)
                    (unless (suppress-history problem)
                      (h:push-item problem h:current))
                    (clear-message problem :all)
                    (d:clear-arrows copy)
                    (d:clear-highlights copy)
                    ;; it may not seem needed but multiparent boxes stay selected sometimes
                    (d:clear-selected (d:root diagram))
                    (d:clear-highlights (d:root diagram))
                    (setf h:current (make-instance 'h:item
                                                   :data (tree:copy-node (d:root diagram) t)
                                                   :extra transformation
                                                   :correctp t))
                    (update-guided-state problem :stage)
                    ;; Yes, a copy so it doesn't corrupt the history
                    (finish-select-mode problem (tree:copy-node copy t) trans)
                    (log problem 'operation :name opname :successful t :new-tree (u:sharp-dot (d:root (diagram problem))))
                    (when (guidedp problem) (show-hint problem))
                    t)
                  (progn
                    (incf (incorrect-operations problem))
                    (log problem 'operation :name opname :successful nil)
                    (display-message problem :error "~a cannot be done with the current selection." (substitute #\Space #\- (string-capitalize opname)))
                    nil)))))))))

(defmethod show-hint ((problem problem))
  (let ((tree (d:root (diagram problem))))
    (d:clear-arrows tree)
    (cond
      ((not (correct-so-far-p problem))
       (show-hint-already-wrong problem))
      ((d:find-if-on-tree (lambda (n) (typep n 'd:input-argument))
                          tree)
       (show-hint-fill-input problem tree))
      (t
       (multiple-value-bind (selection op trans) (guide:get-selection tree (operations problem))
         (let* ((selected-nodes (d:selected-nodes tree))
                (arrows (set-exclusive-or selected-nodes selection)))
           (cond
             ((and op
                   (null arrows))
              (show-hint-choose-operation problem op))
             (selection
              (show-hint-make-selection problem trans selected-nodes selection))
             (t (show-hint-finished problem)))))))))

(defun correct-so-far-p (problem)
  (and (every 'h:item-correctp (h:before problem))
       (h:item-correctp (h:current problem))))

(defmethod next-problem ((problem problem))
  (with-slots (operations diagram) problem
    (cond
      ((or (eq (mode problem) :fill)
           (not (o:no-more-valid-operations-p diagram operations)))
       (log problem 'next-problem-attempt :reason :not-finished)
       (display-message problem :error "The problem is not finished. There is still more you can do.")
       nil)
      ((not (correct-so-far-p problem))
       (log problem 'next-problem-attempt :reason :mistake)
       (display-message problem :error "You've made a mistake! Click first mistake to return to the last correct diagram.")
       nil)
      (t (finish-problem problem)
         t))))

(defmethod navigate-clean-up progn ((problem problem) how))
(defmethod post-navigate-clean-up progn ((problem problem) how))

(defun navigate-search-function (problem)
  (if (navigate-skip-fills-p problem)
      (lambda (i) (not (h:item-extra i)))
      (lambda (i)
        (or (not (h:item-extra i))
            (o:surgeryp (h:item-extra i))))))

(defmethod navigate-back-item ((problem problem))
  (h:last-if problem (navigate-search-function problem)))

(defmethod navigate-forward-item ((problem problem))
  (h:next-if problem (navigate-search-function problem)))

(defmethod navigate-first-mistake-item ((problem problem))
  (let ((c (h:last-correct-state-item problem)))
    (when c
      (if (or (navigate-skip-fills-p problem)
              (not (o:surgeryp (h:item-extra c))))
          (h:item-before problem c)
          c))))

(defmethod navigate ((problem problem) how &optional post-navigation-fn)
  (let ((item (ecase how
                (:back (navigate-back-item problem))
                (:forward (navigate-forward-item problem))
                (:first-mistake (navigate-first-mistake-item problem)))))
    (if item
        (progn
          (h:jump problem item)
          (navigate-clean-up problem how)
          (clear-message problem :all)
          (update-guided-state problem :stage)
          (with-slots (diagram transformation answers h:current mode) problem
            (setf (d:root diagram) (tree:copy-node (h:item-data (h:current problem)) t)
                  transformation (h:item-extra h:current)
                  answers (when transformation
                            (o:generate-answers transformation (d:root diagram)))
                  mode (if (h:item-extra h:current)
                           :fill :select))
            (d:clear-selected (d:root diagram))
            (post-navigate-clean-up problem how)
            (log problem 'navigate :action how :successful t :new-tree (u:sharp-dot (d:root diagram))))
          (when post-navigation-fn
            (funcall post-navigation-fn))
          (ecase how
            (:forward)
            (:back)
            (:first-mistake
             (display-message problem :fyi "This is the diagram before you made your first mistake.")))
          (when (guidedp problem) (show-hint problem))
          t)
        (progn
          (log problem 'navigate :action how :successful nil)
          (when (eq how :first-mistake)
            (display-message problem :error "No mistakes have been made up to this point."))
          nil))))

(defun calculate-reward (problem)
  (let ((fill-states (loop for i in (h:before problem)
                        when (h:item-extra i)
                        collect (h:item-extra i))))
    (values
     (cond
       ((eq (guidedp problem) t)
        0)
       (t
        (max (- (loop for i in fill-states
                   sum (or (o:reward i)
                           (reward-per-operation problem)))
                (* (num-hints problem) (penalty-per-hint problem))
                (* (fill-mistakes problem) (penalty-per-fill-mistake problem))
                (* (incorrect-operations problem) (penalty-per-operation problem)))
             0)))
     (length fill-states)
     (num-hints problem)
     (fill-mistakes problem)
     (incorrect-operations problem))))

(defun parse-old (problem &optional (x (make-instance 'd:multi-argument-box)))
  (labels ((parse (p)
             (cond
               ((listp p)
                (if (eq (first p) '=)
                    (cond
                      ((and (listp (second p))
                            (not (listp (third p))))
                       `(m (a ,(third p) ,(third (parse (second p))))))
                      ((and (listp (third p))
                            (not (listp (second p))))
                       `(m (a ,(second p) ,(third (parse (third p))))))
                      (t
                       `(m (a nil ,(third (parse (second p))) ,(third (parse (third p)))))))
                    `(a nil (m ,@(let ((args (mapcar #'parse p)))
                                      (list* (second args)
                                             (first args)
                                             (cddr args)))))))
               ((and (symbolp p)
                     (char-equal (char (symbol-name p) 0) #\x))
                `(a nil ,x))
               (t
                `(a ,p)))))
    (o:generate-tree
     nil
     (if (eq (first problem) '=)
         (parse problem)
         `(s ,(parse problem))))))
